home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / bipl.zip / PROCS.ZIP / SOUNDEX1.ICN < prev    next >
Text File  |  1992-09-28  |  3KB  |  83 lines
  1. ############################################################################
  2. #
  3. #    File:     soundex1.icn
  4. #
  5. #    Subject:  Procedures for Soundex algorithm
  6. #
  7. #    Author:   John David Stone
  8. #
  9. #    Date:     March 13, 1992
  10. #
  11. ###########################################################################
  12. #
  13. #  When names are communicated by telephone, they are often transcribed
  14. #  incorrectly.  An organization that has to keep track of a lot of names has
  15. #  a need, therefore, for some system of representing or encoding a name that
  16. #  will mitigate the effects of transcription errors.  One idea, originally
  17. #  proposed by Margaret K. Odell and Robert C. Russell, uses the following
  18. #  encoding system to try to bring together occurrences of the same surname,
  19. #  variously spelled:
  20. #
  21. #  Encode each of the letters of the name according to the
  22. #  following equivalences:
  23. #
  24. #        a, e, h, i, o, u, w, y -> *
  25. #        b, f, p, v             -> 1
  26. #        c, g, j, k, q, s, x, z -> 2
  27. #        d, t                   -> 3
  28. #        l                      -> 4
  29. #        m, n                   -> 5
  30. #        r                      -> 6
  31. #
  32. #
  33. #  If any two adjacent letters have the same code, change the code for the
  34. #  second one to *.
  35. #
  36. #  The Soundex representation consists of four characters: the initial letter
  37. #  of the name, and the first three digit (non-asterisk) codes corresponding
  38. #  to letters after the initial.  If there are fewer than three such digit
  39. #  codes, use all that there are, and add zeroes at the end to make up the
  40. #  four-character representation.
  41. #
  42. ############################################################################
  43.  
  44. procedure soundex(name)
  45. local
  46.     coded_name, new_name
  47.  
  48.     coded_name := encode(strip(name))
  49.     new_name := name[1]
  50.     every pos := 2 to *coded_name do {
  51.         if coded_name[pos] ~== "*" then
  52.             new_name := new_name || coded_name[pos]
  53.         if *new_name = 4 then
  54.             break
  55.     }
  56.     return new_name || repl ("0", 4 - *new_name)
  57. end
  58.  
  59. procedure encode(name)
  60.  
  61.     name := map(name, &ucase, &lcase)
  62.     name := map(name, "aehiouwybfpvcgjkqsxzdtlmnr",
  63.         "********111122222222334556")
  64.     every pos := *name to 2 by -1 do
  65.         if name[pos - 1] == name[pos] then
  66.             name[pos] := "*"
  67.     return name
  68. end
  69.  
  70. procedure strip(name)
  71. local
  72.     result
  73. static
  74.     alphabet
  75. initial alphabet := string(&letters)
  76.  
  77.     result := ""
  78.     every ch := !name do
  79.         if find(ch, alphabet) then
  80.             result ||:= ch
  81.     return result
  82. end
  83.